home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-05 / fp2_x102.zip / FP2_XLIB.PRG < prev   
Text File  |  1991-08-16  |  43KB  |  1,558 lines
  1. *
  2. *
  3. *  FP2_XLIB version 1.02        Release date 08-17-1991
  4. *                               Author       Edward M. Rauh
  5. *                                            Gamboge International
  6. *                                            300 Long Beach Blvd.
  7. *                                            Stratford, CT  06497
  8. *                                            FAX 203/386-9333
  9. *
  10. * Changes in 1.02:
  11. *
  12. *  new UDF - CHG_DIR(newpath,set_2_dflt)
  13. *
  14. *               changes directories on non-default drives, optionally
  15. *               sets new path to default.  Does not use RUN/!
  16. *
  17. *  new UDF - ISBN_CKD(booknumb)
  18. *
  19. *               cacluates the check digit needed to convert a 9-digit
  20. *               book number to an ISBN
  21. *
  22. *  Reductions in use of & operator to improve speed
  23. *
  24. *  No, the job server is not being released yet for FoxPro2 - you can
  25. *  still use the one I released for Foxbase+ in LAN_PROC;  it is likely
  26. *  that the FoxPro 2 specific version will be a commercial product in
  27. *  conjunction with a Novell/NetBIOS function library written with the
  28. *  C API.
  29. *
  30.  
  31.  
  32. procedure std_init
  33. *
  34. *  Standard Handler Initialization
  35. *
  36. *
  37. *       The Standard Handler estabilishes a known working environment for 
  38. *       FoxPro in the machine.  A few common variables are set up, a private
  39. *       workspace is established for the end-user, an enhanced error recovery
  40. *       handler is initialized and the BAS5 (Basic Access System version 5)
  41. *       work environment is activated.  The existance of a network is 
  42. *       determined by examining the network machine name.  A few standard
  43. *       communication windows are also established for common access use.
  44. *
  45. *
  46. *  in_lan establishes the existance of a NETBIOS machine name by examining
  47. *  SYS(0).  SET EXCLUSIVE should be controlled by this variable.  In Novell
  48. *  networks, the System Login Script should assign a machine name using the
  49. *  MACHINE="name" statement if NETBIOS is not loaded.
  50. *
  51. public in_lan, err_handl
  52. err_handl = .f.
  53. do std_sets     && added to make recreating the standard environment setting
  54.                 && accessible after modification of the operating environment
  55. in_lan =  network() .and. sys(0) # space(15)+'# 0'  && test for NETBIOS machine name
  56. if in_lan
  57.    set exclusive off
  58. else
  59.    set exclusive on
  60. endif
  61. set status off
  62. set brstatus off
  63. set deleted on
  64. *
  65. *  trap_app is used to flag when errors from APPEND BLANK are intercepted
  66. *  trap_use is used to flag when errors from USE statements are intercepted
  67. *
  68. public trap_app, trap_use
  69.  
  70. trap_app = .f.
  71. trap_use = .f.
  72. *
  73. *  err_hand is a much-enhanced error processing routine for FoxPro2
  74. *
  75. on error do err_hand with error(),message(),program(),message(1),lineno()
  76. err_handl = .t.
  77. *
  78. *  xlib is a standard error message window
  79. *  xdlg is a standard system dialog window at the screen bottom
  80. *
  81. define window xlib from 0,0 to 2,79 nofloat nogrow nozoom noclose color scheme 9
  82. define window xdlg from 22,0 to 24,79 nofloat nogrow nozoom noclose color scheme 11
  83.  
  84. activate window xdlg top
  85. @ 0,23 say 'Initializing FoxPro Environment'
  86. activate screen
  87. *
  88. *       wk_dir is a private working directory, on the drive specified by the
  89. *              DOS environment variable WKDRV
  90. *       wk_files is a guarenteed unique 8-character filename;  I usually
  91. *              reference it as (wk_dir+'\'+wk_files+'.<ext>')
  92. *       in_dir is the initial working directory
  93. *       _ret_act is a procedure to be executed on select by pickone();  it is
  94. *              a global variable (I'm lazy, and you can't necessary pick up
  95. *              other locals inside a UDF) so make sure to save the old value
  96. *              whenever you change it
  97. *       userid is a user identifier passed by the DOS environment variable
  98. *              USERID
  99. *       viewnum is used to store context switching activation, it is used by
  100. *              several routines not included in this release of my library
  101. *       help_topic specifies the active help topic for BAS5HELP
  102. * 
  103. public wk_dir, in_dir, wk_files, _ret_act, userid, viewnum, help_topic
  104.  
  105. viewnum = 0
  106. _ret_act = ''
  107. in_dir = sys(5) + curdir()
  108. wk_dir = getenv('WKDRV')
  109. set default to (wk_dir)
  110. wk_dir = sys(5) + curdir() + sys(3)
  111. set default to (in_dir)
  112. ! md &wk_dir >nul
  113. help_topic = 'Error Messages'
  114. if file('BAS5HELP.DBF') .and. file('BAS5HELP.FPT')
  115.    set help to BAS5HELP
  116.    set help on
  117. else
  118.    set help off
  119. endif
  120. on key label F1 do pophelp
  121. if file('BAS5KEYS.FKY')                 && BAS5KEYS sets Alt-C to Activate
  122.    restore macros from BAS5KEYS         && the calculator
  123.    on key label F2 do popcalc
  124.    on key label Shift-F2 do calc_kbd
  125. endif
  126. wk_files = sys(3)
  127.  
  128. on key label Shift-F1 do sel_pdev
  129. userid = getenv('USERID')
  130. set function 2 to ''
  131. set function 3 to ''
  132. set function 4 to ''
  133. set function 5 to ''
  134. set function 6 to ''
  135. set function 7 to ''
  136. set function 8 to chr(23)               && I use F8 rather than ^W to exit
  137. set function 9 to ''                    && from screens
  138. set function 10 to ''
  139. deactivate window xdlg
  140.  
  141. return
  142.  
  143. procedure std_sets
  144. *
  145. *  Reestablish the standard environment settings
  146. *
  147. set step off
  148. set echo off
  149. set talk off
  150. set debug off
  151. set safety off
  152. set confirm off
  153. set exact off
  154. set escape off
  155. set help off
  156. set reprocess to 10
  157. set near on
  158. *
  159. *  The following was added to allow the standard error handler to be reenabled
  160. *  by calling std_sets after having invoked it with std_init
  161. *
  162. if type('err_handl')='L'
  163.    if err_handl
  164.       on error do err_hand with error(),message(),program(),message(1),lineno()
  165.    endif
  166. endif
  167. return
  168.  
  169. procedure pophelp
  170. *
  171. *  Pophelp will activate the FoxPro context sensitive help facility if the
  172. *  Help file has been activated.
  173. *
  174. if set('HELP')='ON'
  175.    help &help_topic
  176. else 
  177.    wait 'No Help File available' window timeout 60
  178. endif
  179. return
  180.  
  181. procedure popcalc
  182. *
  183. *  Popcalc pops up the calculator if the Alt-C macro from BAS5KEYS is defined
  184. *
  185. play macro Alt_C
  186. retry
  187.  
  188. proc calc_kbd
  189. *
  190. * Calc_kbd takes the content of the calculator and places it in the current
  191. * variable or field being edited on-screen.  The code is non-intuitive;  it
  192. * checks the context of the current variable being edited to see if it is a
  193. * field or memory variable, determines the size and type of data being edited,
  194. * and then converts the calculator data to fit the field in question if it
  195. * can, or converts it to a string and keyboards the result if no better
  196. * solution can be found.
  197. *
  198. private varnm,calcstr,holdfld,fldnm
  199. calcstr = ltrim(str(_calcvalue,18,7))
  200. do while right(calcstr,1) = '0'
  201.    calcstr = left(calcstr,len(calcstr)-1)
  202. enddo
  203. varnm = varread()
  204. fldnm = alias()+'.'+varnm
  205. varnm = 'm.'+varnm
  206. clear typeahead
  207. do case
  208. case type(varnm) $ 'UDLS' .and. type(fldnm) $ 'UDL'
  209.    keyboard calcstr
  210. case type(varnm) $ 'UDLS'  && Has to be a field
  211.    do case
  212.    case type(fldnm) $ 'NF'
  213.       replace &fldnm with _calcvalue
  214.    case type(fldnm) = 'C'
  215.       replace &fldnm with calcstr
  216.    otherwise && Memo Field
  217.       keyboard calcstr
  218.    endcase
  219. case type(fldnm)$'UDL'
  220.    do case
  221.    case type(varnm) $ 'NF'
  222.       &varnm = _calcvalue
  223.    case type(varnm) = 'C'
  224.       calcstr = left(calcstr+space(len(eval(varnm))),len(eval(varnm)))
  225.       &varnm = calcstr
  226.    otherwise && Different File or illegal field type
  227.       keyboard calcstr
  228.    endcase
  229. case type(varnm)$'NF' .and. .not. type(fldnm)$'NF'
  230.    &varnm = _calcvalue
  231. case type(varnm)$'NF'
  232.    if reclock()
  233.       holdfld = eval(fldnm)
  234.       repl &fldnm with .11111111
  235.       calcstr = ltrim(str(_calcvalue,fsize(&fldnm), -int(log10(.11111111-eval(fldnm)))))
  236.       repl &fldnm with holdfld
  237.    endif
  238.    keyboard calcstr
  239. case type(fldnm)$ 'NF'
  240.    repl &fldnm with _calcvalue
  241. case type(fldnm)='M'
  242.    keyboard left(calcstr, min(len(calcstr), len(eval(varnm))))
  243. otherwise
  244.    keyboard left(calcstr, min(len(calcstr), min(len(eval(varnm)),len(eval(fldnm)))))
  245. endcase
  246. return
  247.  
  248.  
  249. procedure prg_exit
  250. *
  251. *  Exit from program and clean up temp files on work drive
  252. *
  253. parameters errmsg
  254. private erasefil
  255. set escape off
  256. on key
  257. set device to screen
  258. set console on
  259. set print off
  260. activate screen
  261. close databases
  262. flush
  263. if type('errmsg')#'C'
  264.    errmsg = ''
  265. endif
  266. do instruct with errmsg+' - returning to DOS'
  267. ?
  268. flush
  269. *
  270. *  Check to see if the temporary work directory is empty - if not, we
  271. *  must erase all files in the directory before removing it!
  272. *
  273. set default to (in_dir)
  274. erasefil = sys(2000,wk_dir+'\*.*')
  275. clear typeahead
  276. if .not. empty(erasefil)
  277.    set printer to yes.ans
  278.    ??? 'Y'+chr(13)
  279.    set printer to
  280.    flush
  281.    !erase &wk_dir <yes.ans
  282.    erase yes.ans
  283. endif
  284. ! rd &wk_dir >nul               && I _REALLY_ want to get rid of this!
  285. quit
  286.       
  287.    
  288. function fillock
  289. *
  290. *  Recoverable File lock acquisition
  291. *
  292. private setc, give_up
  293. setc = save_env()
  294. set console on
  295. set device to screen
  296. set print off
  297. if .not. flock()
  298.    give_up = .f.
  299.    activate window xlib in screen top
  300.    clear
  301.    clear typeahead
  302.    do while .not. (flock() .or. give_up)
  303.       @ 0,0 say 'Waiting for file '+trim(alias())+' - abort?' get give_up picture 'Y'
  304.       read timeout 2
  305.    enddo
  306.    clear
  307.    deactivate window xlib
  308. endif
  309. do rest_env with &setc
  310. return flock()
  311.  
  312.  
  313. function reclock
  314. *
  315. * Recoverable Single record lock acquisition
  316. *
  317. private setc, give_up
  318.  
  319. setc = save_env()
  320. set console on
  321. set device to screen
  322. set print off
  323. if .not. rlock()
  324.    give_up = .f.
  325.    activate window xlib in screen top
  326.    clear
  327.    clear typeahead
  328.    do while .not. (rlock() .or. give_up)
  329.       @ 0,0 say 'Waiting for record '+ltrim(str(recno(),9))+' in '+trim(alias())+' - abort?' get give_up picture 'Y'
  330.       read timeout 2
  331.    enddo
  332.    clear
  333.    deactivate window xlib
  334. endif
  335. do rest_env with &setc
  336. return rlock()
  337.  
  338.  
  339. PROCEDURE err_hand
  340. *
  341. *  Standard Error Processing Routine
  342. *
  343. parameters errnum, mess, curr_prg, bad_line,bad_lineno
  344. *
  345. *  errnum       FoxPro Error Message Number
  346. *  mess         FoxPro Error Description
  347. *  curr_prg     Interrupted Procedure Name
  348. *  bad_line     Interrupted Statement
  349. private setconsole,setdevice,setprint,setcolor
  350.  
  351. setconsole = sys(100)
  352. setdevice = sys(101)
  353. setprint = sys(102)
  354. setcolor = sys(2001,'COLOR')
  355. set console on
  356. set device to screen
  357. set print off
  358.  
  359. private err_screen,errlogfile
  360.  
  361. errlogfile = in_dir+sys(3)
  362. save screen to err_screen
  363.  
  364.  
  365. do case errnum
  366. case trap_app .and. errnum = 108
  367.    activate window xlib top
  368.    @ 0,0 say padc('Waiting for append in file '+trim(alias())+' - <Esc> to abort',78)
  369.    trap_app = inkey() # 27
  370.    if trap_app
  371.       retry
  372.    else
  373.       return
  374.    endif
  375.    
  376. case trap_app
  377.    trap_app = .f.
  378.    return
  379.    
  380. case trap_use .and. errnum = 108
  381.    activate window xlib top
  382.    @ 0,0 say padc('Waiting to open file '+use_alias+' - <Esc> to abort',78)
  383.    trap_use = inkey() # 27
  384.    if trap_use
  385.       retry
  386.    else
  387.       return
  388.    endif
  389.    
  390. case trap_use
  391.    trap_use = .f.
  392.    return
  393.    
  394. case errnum = 216
  395.    set console &setconsole
  396.    set device to &setdevice
  397.    set print &setprint
  398.    set color to &setcolor
  399.    return
  400.  
  401. case errnum = 4 .and. approved(.f.,'EOF limit exceeded - use EOF?',600)
  402.    go bottom
  403.    set console &setconsole
  404.    set device to &setdevice
  405.    set print &setprint
  406.    set color to &setcolor
  407.    restore screen from err_screen
  408.    if .not. bof()
  409.       retry
  410.    else
  411.       return
  412.    endif
  413.  
  414. case errnum = 1405 .and. approved(.f.,'Unable to run external program - proceed anyway?',600)
  415.    set console &setconsole
  416.    set device to &setdevice
  417.    set print &setprint
  418.    set color to &setcolor
  419.    return
  420.  
  421. case errnum = 1405 .and. approved(.f.,'Retry '+ alltrim(bad_line) + '?',600)
  422.    set console &setconsole
  423.    set device to &setdevice
  424.    set print &setprint
  425.    set color to &setcolor
  426.    retry
  427.  
  428. case errnum = 38 .and. approved(.f.,'BOF exceeded - position at BOF?',600)
  429.    go top
  430.    set console &setconsole
  431.    set device to &setdevice
  432.    set print &setprint
  433.    set color to &setcolor
  434.    restore screen from err_screen
  435.    if .not. eof()
  436.       retry
  437.    else
  438.       return
  439.    endif
  440.  
  441. case errnum = 108 .and. upper(left(alltrim(bad_line),3)) # 'USE'
  442.    if fillock()
  443.       set console &setconsole
  444.       set device to &setdevice
  445.       set print &setprint
  446.       set color to &setcolor
  447.       restore screen from err_screen
  448.       retry
  449.    else
  450.       do prg_exit with "Failed to lock file."
  451.    endif
  452.  
  453. case errnum = 108
  454.    activate window xlib
  455.    clear
  456.    @ 0,0 say 'Waiting on '+bad_line
  457.    if inkey(4) # 27
  458.       set console &setconsole
  459.       set device to &setdevice
  460.       set print &setprint
  461.       set color to &setcolor
  462.       deactivate window xlib
  463.       retry
  464.    else
  465.       do prg_exit with 'Failed to open file'
  466.    endif
  467.  
  468. case errnum = 109 .or. errnum = 130
  469.    if reclock()
  470.       set console &setconsole
  471.       set device to &setdevice
  472.       set print &setprint
  473.       set color to &setcolor
  474.       restore screen from err_screen
  475.       retry
  476.    else
  477.       do prg_exit with "Failed to lock record."
  478.    endif
  479.  
  480. case errnum = 124
  481.    set printer to
  482.    set color to &setcolor
  483.    set console &setconsole
  484.    set device to &setdevice
  485.    set print &setprint
  486.    restore screen from err_screen
  487.    return
  488.  
  489. case errnum = 125
  490.    activate window xlib
  491.    clear
  492.    @ 0,0 say 'Printer not ready.  Redirect printer output with Shift-F1'
  493.    clear typeahead
  494.    do while sys(13) = 'OFFLINE' .and. approved('Continue waiting for printer to be fixed?',2)
  495.       ?? chr(7)
  496.    enddo
  497.    deactivate window xlib
  498.    if sys(13) = 'OFFLINE'
  499.       do prg_exit with 'User aborted program.'
  500.    endif
  501.    restore screen from err_screen
  502.    set console &setconsole
  503.    set device to &setdevice
  504.    set print &setprint
  505.    set color to &setcolor
  506.    retry
  507.  
  508. otherwise
  509.    hide windows all
  510.    activate screen
  511.    @ 15,0 clear to 20,79
  512.    @ 0,0 say mess color +W/N
  513.    @ 15,0 to 20,79 double color +W/N
  514.    @ 16,8 say 'A fatal system error has occurred.  The program cannot continue.'
  515.    @ 17,8 say 'The run-time environment will be dumped to the file ERROR.LOG'
  516.    @ 18,8 say 'in the directory '+in_dir
  517.    @ 19,8 say 'Please notify Ambassador Book about this error promptly.'
  518.    set color to &setcolor
  519.    private setprtdev,disknotful
  520.    setprtdev = sys(6)
  521.    set printer to
  522.    disknotful = 'errnum # 56 .or. curdir() # in_dir'
  523.    on error set printer to 
  524.    set printer to (in_dir+'error.log') additive
  525.    on error do prg_exit with ''
  526.    set device to print
  527.    @ 1,10 say 'System error number '+ltrim(str(errnum,4))
  528.    @ 2,10 say mess
  529.    @ 4,10 say 'Called from '+curr_prg
  530.    @ 6,10 say time()
  531.    @ 6,20 say date()
  532.    @ 6,30 say 'User Name '+getenv('USERID')
  533.    @ 7,0 say '...'
  534.    @ 7,pcol()+3 say bad_lineno
  535.    @ 8,0 say bad_line
  536.    set device to screen
  537.    set console off
  538.    do instruct with 'Listing RunTime Status'
  539.    list status to print
  540.    do instruct with 'Listing Program Private Storage'
  541.    list memory to print
  542.    eject page
  543.    set console on
  544.    set printer to
  545.    if file(in_dir+'ORD.PRG')
  546.       if approved('Suspend program execution but stay in FoxBase+?')
  547.          on error
  548.          set talk on
  549.          set help on
  550.          set help to
  551.          suspend
  552.       endif
  553.    endif
  554.    do prg_exit with 'FoxBase+ runtime error occurred'
  555.  
  556. endcase
  557.  
  558. return
  559.  
  560.  
  561. procedure instruct
  562. *
  563. *  Display message on line 24
  564. *
  565. parameter msgln
  566. private setc
  567. setc = save_env()
  568. set device to screen
  569. activate screen
  570. @ 24,0 say padc(msgln,79)
  571. do rest_env with &setc
  572. return
  573.  
  574. function approved
  575. *
  576. *  Get yes or no response
  577. *
  578. parameter myanswer, question, op_dly
  579. private setc, w_name,w_pos
  580. if type('question') # 'C'
  581.    if type('question') = 'N'
  582.       op_dly = question
  583.    endif
  584.    question = myanswer
  585.    myanswer = .t.
  586. endif
  587. question = trim(question)
  588. w_name = 'A_'+alltrim(sys(2))
  589. w_pos = int((75 - len(question))/2)
  590. define window (w_name) from 21,w_pos to 23,w_pos+len(question)+4 in screen double shadow color scheme 6
  591. setc = save_env()
  592. set console on
  593. set device to screen
  594. set print off
  595. activate window (w_name) top
  596. @ 0,0 say question get myanswer picture 'Y' color scheme 8 
  597. if type('op_dly') = 'N'
  598.    read timeout op_dly
  599. else
  600.    read
  601. endif
  602. release window (w_name)
  603. do rest_env with &setc
  604. return myanswer
  605.  
  606.  
  607. function askchar
  608. *
  609. *  Get a single character response from a limited set
  610. *
  611. parameter question, valid_list
  612. private setc,myanswer
  613. setc = save_env()
  614. set console on
  615. set device to screen
  616. set print off
  617. activate window xdlg top
  618. clear
  619. myanswer = ' '
  620. @ 0,0 say trim(padc(question,78)) get myanswer picture '!' valid  myanswer $ valid_list error 'Select one of "'+valid_list+'"'
  621. read
  622. do rest_env with &setc
  623. deactivate window xdlg
  624. return myanswer
  625.  
  626. function appblank
  627. *
  628. *  Recoverable append blank
  629. *
  630. private setc
  631. setc = save_env()
  632. set console on
  633. set device to screen
  634. set print off
  635. private append_ok
  636. trap_app = .t.
  637. append blank
  638. unlock
  639. append_ok = trap_app
  640. trap_app = .f.
  641. if append_ok
  642.    append_ok = reclock()
  643. endif
  644. deactivate window xlib
  645. do rest_env with &setc
  646. return append_ok
  647.  
  648. function use_db
  649. *
  650. *  Recoverable file open
  651. *
  652. parameters dbfname, use_args
  653. private setc,use_ok
  654. setc = save_env()
  655. set console on
  656. set device to screen
  657. set print off
  658. trap_use = .t.
  659. if parameters() < 2 .or. type('use_args') # 'C'
  660.    use_args = ''
  661. endif
  662. use (dbfname) &use_args
  663. use_ok = trap_use
  664. trap_use = .f.
  665. deactivate window xlib
  666. do rest_env with &setc
  667. return use_ok 
  668.  
  669.  
  670. function save_env
  671. *
  672. *  Save standard runtime environment as a single string variable
  673. *
  674. private _rv
  675. _rv = '['+set('DEVICE')+'],['+set('CONSOLE')+'],['+set('PRINTER')+'],['
  676. _rv = _rv+set('COLOR',1)+'],['+set('ALTERNATE')+'],['+woutput()+']'
  677. return _rv
  678.  
  679.  
  680. procedure rest_env
  681. *
  682. *  Restore environment from single string expanded as parameters
  683. *
  684. parameters _dvc, _cns, _ptr, _clr, _alt, _outwin
  685. set device to &_dvc
  686. set console &_cns
  687. set printer &_ptr
  688. set color to &_clr
  689. set alternate &_alt
  690. if empty(_outwin)
  691.    activate screen
  692. else
  693.    activate window (_outwin)
  694. endif
  695. return
  696.  
  697. procedure sel_pdev
  698. *
  699. *  Sel_pdev allows the user to select an appropriate print device, change
  700. *  print modes, send control codes to the printer, make julienne fries, etc.
  701. *  Std_init sets it up to run off of <Shift>F1.  It can also be invoke by
  702. *  DO sel_pdev.  You must ensure that no pop-up array menu is active on-screen
  703. *  at the time Sel_pdev is invoked, or an error will occur and the user will
  704. *  be dropped harmlessly (well, more or less harmlessly) out to DOS.
  705. *
  706. private setc, pdev_in, pdev_wk, m_opt, p_on, spool, prnfile
  707. clear typeahead
  708. on key label Shift-F1
  709. p_on = upper(set('DEVICE')) = 'PRINT' .or. set('PRINT') = 'ON'
  710. pdev_in = set('PRINT',1)
  711. pdev_wk = left(pdev_in+space(64),64)
  712. spool = left(pdev_wk,2)='\\'
  713. prnfile = .not. (spool .or. right(trim(pdev_wk),1) = ':')
  714. m_opt = 1
  715.  
  716. dimension sel_p(4)
  717. sel_p(1) = 'Exit Print Menu'
  718. sel_p(2) = 'Print Device'
  719. sel_p(3) = 'Form Alignment'
  720. sel_p(4) = 'Network Control'
  721.  
  722. setc = save_env()
  723. set console on
  724. set device to screen
  725. set print off
  726.  
  727. define window pdev from 1,1 to 8,78 nofloat nogrow nozoom noclose title 'Print Device Assignment'
  728. activate window pdev in screen top
  729. clear
  730. activate screen
  731. do while m_opt > 0
  732.    do pdev_dsp
  733.    @ 11,1 menu sel_p, iif(in_lan,4,3) title 'Print Control'
  734.    read menu to m_opt
  735.    do case
  736.    case m_opt < 2
  737.       exit
  738.    case m_opt = 2
  739.       do set_pdev
  740.    case m_opt = 3
  741.       do mng_form
  742.    case m_opt = 4
  743.       do net_ctrl
  744.    endcase
  745.    pdev_wk = left(set('PRINT',1)+space(64),64)
  746. enddo
  747. release window pdev
  748. do rest_env with &setc
  749. on key label Shift-F1 do sel_pdev
  750. return
  751.  
  752.  
  753. procedure set_pdev
  754. private numdevs,choice, newdev
  755. numdevs = iif(in_lan,11,10)
  756. choice = iif(spool,11,iif(prnfile,10,1))
  757. dimension p_devs(11)
  758. p_devs( 1) = 'PRN:'
  759. p_devs( 2) = 'LPT1:'
  760. p_devs( 3) = 'LPT2:'
  761. p_devs( 4) = 'LPT3:'
  762. p_devs( 5) = 'COM1:'
  763. p_devs( 6) = 'COM2:'
  764. p_devs( 7) = 'COM3:'
  765. p_devs( 8) = 'AUX:'
  766. p_devs( 9) = 'NUL:'
  767. p_devs(10) = 'DISK'
  768. p_devs(11) = 'NETWORK'
  769. @ 10,40 menu p_devs,numdevs Title 'Print Devices'
  770. read menu to choice
  771. newdev = ''
  772. do case
  773. case choice = 0
  774.    return
  775. case choice < 10
  776.    newdev = p_devs(choice)
  777. case choice = 10
  778.    newdev = putfile('Print to File',iif(prnfile,trim(pdev_wk),'PRINTOUT.TXT'))
  779.    if file(newdev) .and. len(newdev)>0
  780.       if approved('File '+newdev+' exists.  Append?')
  781.          newdev = newdev + ' Additive'
  782.       else
  783.          if .not. approved(.f.,'Overwrite file '+alltrim(newdev)+'?')
  784.             newdev = ''
  785.          endif
  786.       endif
  787.    endif
  788. case choice = 11
  789.    private netp,netf,netb,netc
  790.    netp = 0
  791.    netf = 0
  792.    netb = left(getenv('USERID')+space(12),12)
  793.    netc = 1
  794.    activate window pdev in screen top
  795.    @ 5,0 clear to 5,70
  796.    @ 5,1 say 'Printer # ' get netp picture '#' range 0,4
  797.    @ 5,15 say 'Form ' get netf picture '999' range 0,255
  798.    @ 5,25 say 'Copies ' get netc picture '99' range 1,99
  799.    @ 5,40 say 'Banner (Blank = None)' get netb picture '@!'
  800.    read
  801.    @ 5,0
  802.    activate screen
  803.    newdev='\\SPOOLER\P='+str(netp,1)+'\F='+alltrim(str(netf,3))+'\C='+trim(str(netc,2))+'\'
  804.    newdev = newdev + iif(len(trim(netb))=0,'NB','B='+alltrim(netb))
  805. endcase
  806. if newdev == ''.or. upper(newdev)==upper(pdev_wk) 
  807.    return
  808. endif
  809. set printer to nul:
  810. set console off
  811. eject page
  812. set console on
  813. set printer to (newdev)
  814. if set('PRINT',1)='PRN:' .and. newdev # 'PRN:'
  815.    if prnfile
  816.       set printer to (pdev_wk) additive
  817.    else
  818.       set printer to (pdev_wk)
  819.       if .not. spool
  820.          set console off
  821.          eject page
  822.          set console on
  823.       else
  824.          _pageno = 1
  825.       endif
  826.       _plineno = 0
  827.    endif
  828. else
  829.    _pageno = 1
  830.    _plineno = 0
  831. endif
  832. return
  833.  
  834. procedure mng_form
  835. private choice,pctl_str
  836. dimension acts(4)
  837. choice = 0
  838. acts(1)='Eject to Top of Form'
  839. acts(2)='Top of Form/No Eject'
  840. acts(3)='Send Print Code'
  841. acts(4)='Change Print Status'
  842. do while .t.
  843.    activate screen
  844.    @ 10,40 menu acts,4 title 'Form Control'
  845.    read menu to choice
  846.    do case
  847.    case choice = 0
  848.       exit
  849.    case choice = 1
  850.       set console off
  851.       eject page
  852.       set console on
  853.    case choice = 2
  854.       set printer to nul:
  855.       set console off
  856.       eject page
  857.       set console on
  858.       if prnfile
  859.          set printer to (pdev_wk) additive
  860.       else
  861.          set printer to (pdev_wk)
  862.       endif
  863.    case choice = 3
  864.       activate window xdlg top
  865.       clear
  866.       pctl_str = space(150)
  867.       @ 0,0 say 'Enter String Expression:' get pctl_str picture '@S40' valid type(trim(pctl_str))='C' .or. len(alltrim(pctl_str))=0
  868.       read
  869.       pctl_str = trim(pctl_str)
  870.       if .not. (empty(pctl_str) .or. lastkey()=27)
  871.          ??? evaluate(pctl_str)
  872.       endif
  873.       deactivate window xdlg
  874.    case choice = 4
  875.       activate window pdev in screen top
  876.       @ 4,0 say 'Page: ' 
  877.       @ 4,col() get _pageno picture '9999' range 1,9999
  878.       @ 4,col()+4 say 'Line: ' 
  879.       @ 4,col() get _plineno picture '9999' range 0,_plength-1
  880.       @ 4,col()+4 say 'Column: '
  881.       @ 4,col() get _pcolno picture '999' range 0,_rmargin-1
  882.       @ 4,col()+4 say 'Lines/page: '
  883.       @ 4,col() get _plength picture '999' valid between(_plength, _plineno+1, 255)
  884.       @ 4,col()+4 say 'Cols/line: '
  885.       @ 4,col() get _rmargin picture '999' valid between(_rmargin, _pcolno+1, 255)
  886.       read
  887.       activate screen
  888.    endcase
  889. enddo
  890. return
  891.  
  892. procedure net_ctrl
  893. private choice, scr_in
  894. activate screen
  895. save screen to scr_in
  896. dimension nact(4)
  897. nact(1) = 'PCONSOLE'
  898. nact(2) = 'PRINTCON'
  899. nact(3) = 'PRINTDEF'
  900. nact(4) = 'Release Print Job'
  901. choice = 0
  902. @ 10,40 menu nact,4 title 'Network Control'
  903. read menu to choice
  904. do case
  905. case choice = 1
  906.    run /0 pconsole
  907. case choice = 2
  908.    run /0 printcon
  909. case choice = 3
  910.    run /0 printdef
  911. case choice = 4
  912.    if spool .or. .not. prnfile
  913.       set console off
  914.       set printer to nul:
  915.       eject page
  916.       set printer to (pdev_wk)
  917.       set console on
  918.    endif
  919. endcase
  920. restore screen from scr_in
  921. return
  922.  
  923. procedure pdev_dsp
  924. activate window pdev in screen top
  925. spool = left(pdev_wk,2)='\\'
  926. prnfile = .not. (spool .or. right(trim(pdev_wk),1) = ':')
  927. @ 0,0 say 'Printer Assignment: ' get pdev_wk picture '@!S45'
  928. @ 2,0 say 'Printer '+iif(p_on,'A','Ina')+'ctive   '
  929. @ 2,22
  930. do case
  931. case spool
  932.    @ 2,22 say 'SPOOLING TO NETWORK QUEUE - Spool'+ iif(_pageno+_plineno>1,' active',' empty')
  933. case prnfile
  934.    @ 2,22 say 'PRINTING TO DISK FILE'
  935. otherwise
  936.    @ 2,22 say 'PRINTER '+sys(13)
  937. endcase
  938. @ 4,0 say 'Page: ' 
  939. @ 4,col() say _pageno picture '9999'
  940. @ 4,col()+4 say 'Line: ' 
  941. @ 4,col() say _plineno picture '9999'
  942. @ 3, col()-5 say '('+str(prow(),4)+')'
  943. @ 4,col()+3 say 'Column: '
  944. @ 4,col() say _pcolno picture '999'
  945. @ 3,col()-4 say '('+str(pcol(),3)+')'
  946. @ 4,col()+3 say 'Lines/page: '
  947. @ 4,col() say _plength picture '999'
  948. @ 4,col()+4 say 'Cols/line: '
  949. @ 4,col() say _rmargin picture '999' 
  950. clear gets
  951. activate screen
  952. return
  953.  
  954. function pickone
  955. parameters disp_line,win_head,match_test,key_prefix,ul_row,ul_col,num_rows,kill_after,win_name
  956. *
  957. *  PickOne() - display and scroll through a FoxBase+ database on screen
  958. *              in a pop-up window.  Allow preconditioning of user-entered
  959. *              keys and prevent selection of any records not meeting the
  960. *              specified matching condition
  961. *
  962. *   Returns:   .T. if choice was made.  CWA positioned on selection.
  963. *              .F. if Esc was pressed.  CWA positioned as at entry.
  964. *
  965. *              Fatal errors suspend program, return .F. if resumed
  966. *
  967. *   Arguments:
  968. *              disp_line  - <ExpC>, macro of detail line content.  Must be
  969. *                           expanded to a fixed-length string
  970. *
  971. *                           Example: [LastName+" "+str(salary,9,2)+" "+title]
  972. *
  973. *              list_head  - <ExpC>, Title of pop-up box
  974. *
  975. *                           Example: [Sales Department Salaries]
  976. *
  977. *              match_test - <ExpC>, macro of selection criteria test for
  978. *                           valid, selectable records.  Must expand to a
  979. *                           logical expression. Use [.t.] for no test
  980. *
  981. *                           Example: [Department="SALES"]
  982. *
  983. *              key_prefix - <ExpC>, used as prefix on key lookup
  984. *
  985. *                           Example: []
  986. *
  987. *              ul_row     - <ExpN> Range (0..21) First box row
  988. *
  989. *                           Example: 8
  990. *
  991. *              ul_col     - <ExpN> Range (0..71) First box column
  992. *
  993. *                           Example: 4
  994. *
  995. *              num_rows   - <ExpN> Range (1..22-ul_row) Max records on
  996. *                           screen in box at one time.  If a negative
  997. *                           value is passed, a box of abs(num_rows) will
  998. *                           be displayed, but the screen will not be
  999. *                           restored on exit from the routine.
  1000. *
  1001. *                            Example: 8
  1002. *
  1003. *              kill_after - <ExpN> - Maximum time to wait for a user to
  1004. *                           press a key before killing the program.  Use
  1005. *                           -1 to wait forever.
  1006. *
  1007. *                            Example: 600  (e.g. 10 minutes)
  1008. *
  1009. *              win_name   - <ExpC> - Name of window to use to display the
  1010. *                           scrolling window box (default WIN_PICK).  By
  1011. *                           specifying different window names, multiple
  1012. *                           scrolling boxes could be nested.
  1013. *
  1014. ********************************
  1015. *  Sample usage:
  1016. *
  1017. *
  1018. *   && Set up a box containing 8 records at a time anchored at 7,14.
  1019. *   && Show the user str_fld_1, date_fld_2 and num_fld_3 for each record.
  1020. *   && Label the box "This year's entries"
  1021. *   && Only allow the user undeleted records, where the date in date_fld_2
  1022. *   && falls in the current year
  1023. *   && If the user does nothing for 10 minutes, kill the program
  1024. *
  1025. *   showme = 'str_fld_1+[ ]+dtoc(date_fld_2)+[ ]+str(num_fld_3,6,2)'
  1026. *   box_title = "This year's entries"
  1027. *   must_be = '.not. deleted() .and. (year(date_fld_2) = year(date()) )'
  1028. *   top_row = 7
  1029. *   left_col = 14
  1030. *   recs_inbox = 8
  1031. *   quit_in = 600
  1032. *   
  1033. *   a= PickOne(showme,box_title,must_be,'',top_row,left_col,recs_inbox,quit_in)
  1034. ********************************
  1035. *  Validity tests and error handling:
  1036. *
  1037. *       ul_col not in range         - UDF displays error message, program
  1038. *       ul_row not in range           is SUSPENDed
  1039. *       num_rows < 1
  1040. *       type(disp_line) # 'C'
  1041. *       type(match_test) # 'L'
  1042. *       type('key_prefix') # 'C'
  1043. *       type('ul_row') # 'N'
  1044. *       type('ul_col') # 'N'
  1045. *       type('num_rows') # 'N'
  1046. *       type('kill_after') # 'N'
  1047. *
  1048. *       type('list_head') # 'C'     - Box heading is not displayed
  1049. *
  1050. *       ul_row+num_rows > 22        - num_rows reduced to (22-ul_row)
  1051. *
  1052. *       ul_col+len(&disp_line) > 78 - left(&disp_line,78-ul_col) used in
  1053. *                                     place of &disp_line
  1054. *
  1055. *       len(list_head) > boxsize    - left(list_head,boxsize) displayed
  1056. *
  1057. *       type('win_name') # 'C"      - window 'WIN_PICK' is used to display
  1058. *                                     the scrolling box.
  1059. ********************************
  1060. *
  1061. *  Gadgetry:
  1062. *
  1063. *  I write for multiuser environments, where it can be quite damaging for
  1064. *  an end-user to just walk away from a console with their program running,
  1065. *  perhaps while holding an active Flock() or Rlock(), or worse, preventing
  1066. *  someone from making a backup of the open datafiles.  I use a simple
  1067. *  inkey(1) timing loop to knock down the program after some period of 
  1068. *  inactivity in the scroll box, specified in the kill_after parameter.
  1069. *  
  1070. *  The public variable _ret_act can be used to pass the name of a DO procedure
  1071. *  to be executed on making a valid selection by pressing <Return>.  If you
  1072. *  use the pickone() routine recursively, make sure to save value of _ret_act
  1073. *  before invoking pickone() recursively.
  1074. *
  1075.  
  1076. private _up, _down, _left, _right, _bell_chr
  1077. private _pgup, _pgdn, _home, _end, _return, _esc, _f1, _f2
  1078.  
  1079. * The code makes more sense referring to a variable for keystrokes instead
  1080. * of the inkey() values or chr() arguments.
  1081.  
  1082. _up = 5
  1083. _down = 24
  1084. _left = 19
  1085. _right = 4
  1086. _bell_chr = chr(7)
  1087. _pgup = 18
  1088. _pgdn = 3
  1089. _home = 1
  1090. _end = 6
  1091. _return = 13
  1092. _esc = 27
  1093. _f1 = 28
  1094. _f2 = -1
  1095.  
  1096. private _setc
  1097.  
  1098. * _setc preserves the status on entry to the UDF
  1099.  
  1100. _setc = save_env()
  1101.  
  1102. do case                         && Test for fatal error conditions
  1103.  
  1104. case type(disp_line) # 'C'
  1105.    do psb_err with 'Display line argument must evaluate to a string',disp_line
  1106.    return .f.
  1107. case type(match_test) # 'L'
  1108.    do psb_err with 'Record match test must evaluate to a logical expression',match_line
  1109.    return .f.
  1110. case type('key_prefix') # 'C'
  1111.    do psb_err with 'Key prefix must be a character expression',key_prefix
  1112.    return .f.
  1113. case type('ul_row') # 'N'
  1114.    do psb_err with 'Upper left row argument must be numeric',ul_row
  1115.    return .f.
  1116. case type('ul_col') # 'N'
  1117.    do psb_err with 'Upper left column argument must be numeric',ul_col
  1118.    return .f.
  1119. case type('num_rows') # 'N'
  1120.    do psb_err with 'Number of rows argument must be numeric',num_rows
  1121.    return .f.
  1122. case type('kill_after') # 'N'
  1123.    do psb_err with 'Wait time between keys must be numeric',kill_after
  1124.    return .f.
  1125. case ul_col < 0 .or. ul_col > 71
  1126.    do psb_err with 'Upper left column argument out of range (0..71)',ul_col
  1127.    return .f.
  1128. case ul_row < 0 .or. ul_row > 21
  1129.    do psb_err with 'Upper left row argument out of range (0..21)',ul_row
  1130.    return .f.
  1131. endcase
  1132.  
  1133.  
  1134. private on_row,rows,boxbot,boxtop,first_col,boxsize,disp_arg,init_recno
  1135.  
  1136. * on_row is current display row
  1137. * rows is the max records that can be displayed at once
  1138. * boxbot is last display row
  1139. * boxtop is first display row
  1140. * first_col is the first column of the scrolling area
  1141. * boxsize is the width of the scroll area
  1142. * disp_arg is the content of the display line
  1143. * init_recno is the file position at entry to the routine
  1144.  
  1145. if reccount() = 0 .or. bof() .or. eof()
  1146.    return .f.
  1147. endif
  1148.  
  1149. init_recno = recno()
  1150. rows = abs(num_rows)
  1151. rows = iif(rows = 0 .or. rows+ul_row < 23, rows, 22 - ul_row)
  1152. boxbot = rows - 1
  1153. boxtop = 0
  1154. first_col = 0
  1155. disp_arg = disp_line
  1156. boxsize = max(len(evaluate(disp_arg)),7)
  1157. if ul_row + boxsize > 78
  1158.    boxsize = 78 - ul_row
  1159.    disp_arg = 'left(' + disp_line + ',' + str(boxsize,2) + ')'
  1160. endif
  1161.  
  1162. if type('win_name') # 'C'
  1163.    win_name = 'Win_Pick'
  1164. endif
  1165. if wexist(win_name)
  1166.    release window (win_name)
  1167. endif
  1168. define window (win_name) from ul_row,ul_col to ul_row + rows + 1, ul_col + boxsize + 1 double nozoom nogrow float shadow title win_head
  1169. activate window (win_name) top
  1170. on_row = boxtop
  1171. do disprecs
  1172.  
  1173. skip boxtop - on_row
  1174. on_row = boxtop
  1175. do hidisp
  1176.  
  1177. private xkey
  1178.  
  1179. * xkey is the keystroke that exits the selection loop in pickit
  1180.  
  1181. xkey = 0
  1182. do pickit
  1183. do rest_env with &_setc
  1184. if num_rows < 0
  1185.    show window (win_name) save
  1186. endif
  1187. release window (win_name)
  1188.  
  1189. if xkey = _esc 
  1190.    goto init_recno
  1191. endif
  1192.  
  1193. return (xkey # _esc)
  1194.  
  1195.  
  1196. procedure pickit
  1197. private skey, rsave, savrow, helpcnt
  1198.  
  1199. * skey is the ASCII value of the last keystroke scanned
  1200. * rsave saves the record pointer before a seek or skip action
  1201. * savrow holds the highlighted row position before PgUp or PgDn
  1202. * helpcnt works as a countdown timer for some inkey() loops
  1203.  
  1204.  
  1205. set escape off
  1206. do while .t.
  1207.    set cursor off
  1208.    helpcnt = int(kill_after)              &&  if kill_after < 0, wait forever
  1209.    xkey = 0
  1210.    do while (xkey = 0) .and. (helpcnt # 0)
  1211.       xkey = inkey(1)
  1212.       helpcnt = helpcnt - 1
  1213.       if between(helpcnt,1,45)
  1214.          activate window xlib top
  1215.          @ 0,0
  1216.          @ 0,0 say str(helpcnt,3)+' seconds left until user declared inactive!'
  1217.          ?? chr(7)
  1218.       endif
  1219.    enddo
  1220.    set cursor on
  1221.    deactivate window xlib
  1222.    if xkey = 0 .and. helpcnt = 0
  1223.       unlock all
  1224.       do prg_exit with 'Program aborted - no key pressed for '+ltrim(str(kill_after,9))+' seconds'
  1225.    endif
  1226.      skey = iif(xkey > 0,upper(chr(xkey)),'')
  1227.    do case
  1228.    case xkey = _esc
  1229.       exit
  1230.    case ( xkey = _return .and. evaluate(match_test) )
  1231.       if len(alltrim(_ret_act)) = 0
  1232.           exit
  1233.       else
  1234.       if .not. ' ' $ alltrim(_ret_act)
  1235.           do (_ret_act)
  1236.       else
  1237.           do &_ret_act
  1238.       endif
  1239.    case skey >='A' .and. skey <='Z'
  1240.       rsave = recno()
  1241.       seek key_prefix+skey
  1242.       if found()
  1243.          do disprecs
  1244.          skip boxtop - on_row
  1245.          on_row = boxtop
  1246.          do hidisp
  1247.       else
  1248.          ?? _bell_chr
  1249.          goto rsave
  1250.       endif
  1251.    case skey >='0' .and. skey <='9'
  1252.       rsave = recno()
  1253.       seek key_prefix+skey
  1254.       if found()
  1255.          do disprecs
  1256.          skip boxtop - on_row
  1257.          on_row = boxtop
  1258.          do hidisp
  1259.       else
  1260.          ?? _bell_chr
  1261.          goto rsave
  1262.       endif
  1263.  
  1264.    case xkey =  _up .and. .not. bof()
  1265.       if on_row > boxtop
  1266.          do dis
  1267.          on_row = on_row - 1
  1268.          skip -1
  1269.          do hidisp
  1270.       else
  1271.          skip -1
  1272.          if bof()
  1273.             ?? _bell_chr
  1274.             goto top
  1275.          else
  1276.             skip
  1277.             do dis
  1278.             scroll boxtop, first_col , boxbot, first_col + boxsize - 1, -1
  1279.             skip -1
  1280.             on_row = boxtop
  1281.             do hidisp
  1282.          endif
  1283.       endif
  1284.  
  1285.    case xkey =  _down .and. .not. eof()
  1286.       skip
  1287.       if eof()
  1288.          skip -1
  1289.          ?? _bell_chr
  1290.          do hidisp
  1291.       else
  1292.          skip -1
  1293.          do dis
  1294.          skip
  1295.          if on_row < boxbot
  1296.             on_row = on_row + 1
  1297.          else
  1298.             scroll boxtop, first_col , boxbot, first_col + boxsize - 1, 1
  1299.             on_row = boxbot
  1300.          endif
  1301.          do hidisp
  1302.       endif
  1303.  
  1304.    case xkey =  _pgdn .and. .not. eof()
  1305.       savrow = on_row
  1306.       skip boxbot - on_row + 1
  1307.       if eof()
  1308.          ?? _bell_chr
  1309.          go bottom
  1310.       endif
  1311.       do disprecs
  1312.       if on_row > savrow
  1313.          skip savrow - on_row
  1314.          on_row = savrow
  1315.       endif
  1316.       do hidisp
  1317.  
  1318.    case xkey =  _pgup .and. .not. bof()
  1319.       savrow = on_row
  1320.       skip boxtop - on_row - rows
  1321.       if bof()
  1322.          ?? _bell_chr
  1323.          goto top
  1324.       endif
  1325.       do disprecs
  1326.       skip savrow - on_row
  1327.       on_row = savrow
  1328.       do hidisp
  1329.  
  1330.    case xkey =  _home
  1331.       goto top
  1332.       do disprecs
  1333.       goto top
  1334.       on_row = boxtop
  1335.       do hidisp
  1336.  
  1337.    case xkey =  _end
  1338.       goto bott
  1339.       skip 1-rows
  1340.       if bof()
  1341.          go top
  1342.       endif
  1343.       do disprecs
  1344.       do hidisp
  1345.  
  1346.    case xkey = _f1
  1347.       define window wphelp from 1,1 to 20,78 shadow color scheme 10 title 'Pop-up Selection Help'
  1348.       activate window wphelp top
  1349.       clear
  1350.       ? ' This pop-up box will allow you to choose a specific item from a list of'
  1351.       ? ' potential choices by browsing through the list of choices on-screen. Lines'
  1352.       ? ' made up entirely of asterisks (*) cannot be selected from the item list.'
  1353.       ? ' You may select an item by highlighting your choice and pressing the'
  1354.       ? ' <Return> key.  Pressing the <Esc> key exits without selecting an item.'
  1355.       ?
  1356.       ? " <PgUp> and <PgDn> scroll the selection window up or down a page at a time"
  1357.       ? " "+chr(24)+" and "+chr(25)+" scroll the selection window up or down one line at a time"
  1358.       ? " <Home> and <End> move to the first and last entries respectively"
  1359.       ? " A letter (A-Z) or number (0-9) will jump to the first item starting with"
  1360.       ? " that character.  <F2> allows you to specify a search key of more than one"
  1361.       ? ' character length.  <F3> moves to the next eligible selection, while <F4>'
  1362.       ? ' moves to the previous eligible selection in the list.'
  1363.       @ 17,21 SAY "This help box will clear in    seconds"
  1364.       clear typeahead
  1365.       helpcnt = 30
  1366.       do while inkey(1) = 0 .and. helpcnt > 0
  1367.          @ 17,49 SAY helpcnt picture '99' color *N/W
  1368.          helpcnt = helpcnt - 1
  1369.       enddo
  1370.       release window wphelp
  1371.    case xkey = _f2
  1372.       activate window xdlg top
  1373.       clear
  1374.       accept 'Enter desired key--> ' to skey
  1375.       deactivate window xdlg
  1376.       rsave = recno()
  1377.       skey = key_prefix+upper(skey)
  1378.       seek skey
  1379.       do while len(skey) > len(key_prefix)+1 .and. .not. found()
  1380.          skey = left(skey,len(skey)-1)
  1381.          seek skey
  1382.       enddo
  1383.       if found()
  1384.          do disprecs
  1385.          skip boxtop - on_row
  1386.          on_row = boxtop
  1387.          do hidisp
  1388.       else
  1389.          ?? _bell_chr
  1390.          goto rsave
  1391.       endif
  1392.    case xkey = _f2 - 1 .and. .not. eof()
  1393.       rsave = recno()
  1394.       skip
  1395.       do while .not. (eof() .or. evaluate(match_test) )
  1396.          skip
  1397.       enddo
  1398.       if .not. eof()
  1399.          do disprecs
  1400.          skip boxtop - on_row
  1401.          on_row = boxtop
  1402.          do hidisp
  1403.       else
  1404.          ?? _bell_chr
  1405.          goto rsave
  1406.       endif
  1407.    case xkey = _f2 - 2 .and. .not. bof()
  1408.       rsave = recno()
  1409.       skip - 1
  1410.       do while .not. (bof() .or. evaluate(match_test) )
  1411.          skip - 1
  1412.       enddo
  1413.       if .not. bof()
  1414.          do disprecs
  1415.          skip boxtop - on_row
  1416.          on_row = boxtop
  1417.          do hidisp
  1418.       else
  1419.          ?? _bell_chr
  1420.          goto rsave
  1421.       endif
  1422.    endcase
  1423. enddo
  1424. return
  1425.  
  1426. procedure hidisp
  1427. @ on_row,0 say iif(evaluate(match_test),evaluate(disp_arg),repl('*',boxsize)) color N/W
  1428. return
  1429.  
  1430. procedure dis
  1431. @ on_row,0 say iif(evaluate(match_test),evaluate(disp_arg),repl('*',boxsize))
  1432. return
  1433.  
  1434. procedure disprecs
  1435. on_row = boxtop
  1436. clear
  1437. do while .not. eof() .and. .not. on_row = boxbot + 1
  1438.    do dis
  1439.    skip
  1440.    on_row = on_row + 1
  1441. enddo
  1442. on_row = on_row - 1
  1443. skip -1
  1444. return
  1445.  
  1446. procedure psb_err
  1447. parameters error_msg, bad_var
  1448. define window pick_psb from 9,0 to 14,79 panel title 'Window Selection Error'
  1449. activate window pick_psb top
  1450. clear
  1451. @ 0, 38 - (len(error_msg)+1)/2 say error_msg
  1452. @ 2, 31  say 'Value passed was:' color +W/N
  1453. @ 3,0 say bad_var color +W/N
  1454. wait window timeout 60
  1455. release window pick_psb
  1456. return
  1457.  
  1458. function val_crcd
  1459. *
  1460. *  Validates that the character field contains a valid credit card number
  1461. *  using modulo-10 checksumming on alternate digit multipliers
  1462. *
  1463. parameter cardno
  1464. private cksum, is_valid, cardlen, multiplier, i, factor, j
  1465. cardno = alltrim(cardno)
  1466. cardlen = len(cardno)
  1467. is_valid = inlist(cardlen,13,16)
  1468. i = cardlen
  1469. cksum = 0
  1470. multiplier = 1
  1471. do while is_valid .and. i > 0
  1472.    is_valid = isdigit(subst(cardno,i,1))
  1473.    if is_valid
  1474.       factor = alltrim(str(val(subst(cardno,i,1))*multiplier))
  1475.       for j = 1 to len(factor)
  1476.          cksum = cksum + val(subst(factor,j,1))
  1477.       endfor
  1478.    endif
  1479.    i = i - 1
  1480.    multiplier = mod(multiplier,2)+1
  1481. enddo
  1482. is_valid = is_valid .and. (mod(cksum,10) = 0)
  1483. return is_valid
  1484.  
  1485. function val_isbn
  1486. *
  1487. *  Validates that a field contains a valid ISBN
  1488. *  (International Standard Book Number) - requires a 10-character field
  1489. *
  1490. parameter test_str
  1491.  
  1492. if len(test_str) # 10
  1493.    return .f.
  1494. endif
  1495.  
  1496. if test_str = space(10)
  1497.    return .t.
  1498. endif
  1499.  
  1500. private _wk, chksum
  1501.  
  1502. chksum = at(upper(right(test_str,1)), '0123456789X') - 1
  1503. if chksum < 0
  1504.    return .f.
  1505. endif
  1506.  
  1507. _wk = ltrim(str(val(left(test_str, 9)),9))
  1508. if right(repl('0',8)+_wk,9) # left(test_str,9)
  1509.    return .f.
  1510. endif
  1511.  
  1512. _wk = _wk + ' '
  1513. do while len(_wk) > 1
  1514.    chksum = chksum + ( (asc(_wk)-48) * len(_wk))
  1515.    _wk = subst(_wk,2)
  1516. enddo
  1517. return ( mod(chksum,11) = 0)
  1518.  
  1519. procedure chg_dir
  1520. *
  1521. *  CHG_DIR()            Change directory on non-default drive
  1522. *                       and optionally set new directory as default
  1523. *
  1524. parameter new_path, set_2_dflt
  1525. if parameters() = 0
  1526.    wait window '* CHG_DIR() - no path parameter passed' timeout 60
  1527.    return .f.
  1528. endif
  1529. if type('new_path') # 'C'
  1530.    wait window '* CHG_DIR() - path parameter was not a char string' timeout 60
  1531.    return .f.
  1532. endif
  1533. if type('set_2_dflt') # 'L'
  1534.    set_2_dflt = .f.
  1535. endif
  1536. private old_drive, failed_cd
  1537. old_drive = sys(5)
  1538. failed_cd = .f.
  1539. on error failed_cd = .t.
  1540. set default to (new_path)
  1541. do std_sets
  1542. if .not. (set_2_dflt .or. failed_cd)
  1543.    set default to (old_drive)
  1544. endif
  1545. return (.not. failed_cd)
  1546.   
  1547. function isbn_ckd
  1548. parameter booknum
  1549. private chkdigs,pointer
  1550. pointer = 1
  1551. chkdigs = '0123456789X*'
  1552. do while .not. val_isbn(booknum+subst(chkdigs,pointer,1)
  1553.    pointer = pointer + 1
  1554.    if pointer > 11
  1555.       exit
  1556.    endif
  1557. enddo
  1558. return subst(chkdigs,pointer,1)